Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue65/alfresco/TraverseNFA.dpr

Text File | 2000-11-28 | 8.3 KB | 294 lines

{*********************************************************}
{* TraverseNFA                                           *}
{* Copyright (c) Julian M Bucknall 2001                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco: NFA traversal routine            *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

program TraverseNFA;

{$apptype console}

uses
  SysUtils,
  Classes;

type
  PaaCharSet = ^TaaCharSet;
  TaaCharSet = set of char;

  TaaNFAMatchType = (  {types of matching performed...}
     mtNone,           {..no match (an epsilon no-cost move)}
     mtAnyChar,        {..any character}
     mtChar,           {..a particular character}
     mtClass,          {..a character class}
     mtNegClass);      {..a negated character class}

  TaaNFAStateData = record
    sdNextState1: integer;
    sdNextState2: integer;            {-1 means "not used"}
    sdMatchType : TaaNFAMatchType;
    case integer of
      0 : (sdChar  : char);
      1 : (sdClass : PaaCharSet);
  end;

  PaaNFAStateTable = ^TaaNFAStateTable;
  TaaNFAStateTable = packed record
    stStartState: integer;
    stFinalState: integer;
    stTable     : array [0..9999] of TaaNFAStateData;
  end;

{====================================================================}
type
  TaaIntDeque = class
    private
      FList : TList;
      FHead : integer;
      FTail : integer;
    protected
      procedure idGrow;
    public
      constructor Create(aCapacity : integer);
      destructor Destroy; override;

      function IsEmpty : boolean;

      procedure Enqueue(aValue : integer);
      procedure Push(aValue : integer);
      function Pop : integer;
  end;
{--------}
constructor TaaIntDeque.Create(aCapacity : integer);
begin
  inherited Create;
  FList := TList.Create;
  FList.Count := aCapacity;
  {let's help out the user of the deque by putting the head and tail
   pointers in the middle: it's more efficient}
  FHead := aCapacity div 2;
  FTail := FHead;
end;
{--------}
destructor TaaIntDeque.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaIntDeque.Enqueue(aValue : integer);
begin
  FList.List^[FTail] := pointer(aValue);
  inc(FTail);
  if (FTail = FList.Count) then
    FTail := 0;
  if (FTail = FHead) then
    idGrow;
end;
{--------}
procedure TaaIntDeque.idGrow;
var
  OldCount : integer;
  i, j     : integer;
begin
  {grow the list by 50%}
  OldCount := FList.Count;
  FList.Count := (OldCount * 3) div 2;
  {expand the data into the increased space, maintaining the deque}
  if (FHead = 0) then
    FTail := OldCount
  else begin
    j := FList.Count;
    for i := pred(OldCount) downto FHead do begin
      dec(j);
      FList.List^[j] := FList.List^[i]
    end;
    FHead := j;
  end;
end;
{--------}
function TaaIntDeque.IsEmpty : boolean;
begin
  Result := FHead = FTail;
end;
{--------}
procedure TaaIntDeque.Push(aValue : integer);
begin
  if (FHead = 0) then
    FHead := FList.Count;
  dec(FHead);
  FList.List^[FHead] := pointer(aValue);
  if (FTail = FHead) then
    idGrow;
end;
{--------}
function TaaIntDeque.Pop : integer;
begin
  if FHead = FTail then
    raise Exception.Create('Integer deque is empty: cannot pop');
  Result := integer(FList.List^[FHead]);
  inc(FHead);
  if (FHead = FList.Count) then
    FHead := 0;
end;
{====================================================================}

function aaMatchRegEx(aTable  : PaaNFAStateTable;
                      const S : string) : boolean;
const
  MustScan = -1;
var
  Ch    : char;
  State : integer;
  Deque : TaaIntDeque;
  StrInx : integer;
begin
  {assume we fail to match}
  Result := false;
  {create the deque}
  Deque := TaaIntDeque.Create(64);
  try
    {push the special value to start scanning}
    Deque.Enqueue(MustScan);
    {enqueue the first state}
    Deque.Enqueue(aTable^.stStartState);
    {prepare the string index}
    StrInx := 0;
    {loop until the deque is empty or we run out of string}
    while (StrInx <= length(S)) and not Deque.IsEmpty do begin
      {pop the top state from the deque}
      State := Deque.Pop;
      {process the "must scan" state first}
      if (State = MustScan) then begin
        {if the deque is empty at this point, we might as well give up
         since there are no states left to process new characters}
        if not Deque.IsEmpty then begin
          {if we haven't run out of string, get the character, and
           enqueue the "must scan" state again}
          inc(StrInx);
          if (StrInx <= length(S)) then begin
            Ch := S[StrInx];
            Deque.Enqueue(MustScan);
          end;
        end;
      end
      {otherwise, process the state}
      else with aTable^.stTable[State] do begin
        case sdMatchType of
          mtNone :
            begin
              {for free moves, push the next states onto the deque}
              if (sdNextState2 <> -1) then
                Deque.Push(sdNextState2);
              if (sdNextState1 <> -1) then
                Deque.Push(sdNextState1);
            end;
          mtAnyChar :
            begin
              {for a match of any character, enqueue the next state}
              Deque.Enqueue(sdNextState1);
            end;
          mtChar :
            begin
              {for a match of a character, enqueue the next state}
              if (Ch = sdChar) then
                Deque.Enqueue(sdNextState1);
            end;
          mtClass :
            begin
              {for a match within a class, enqueue the next state}
              if (Ch in sdClass^) then
                Deque.Enqueue(sdNextState1);
            end;
          mtNegClass :
            begin
              {for a match not within a class, enqueue the next state}
              if not (Ch in sdClass^) then
                Deque.Enqueue(sdNextState1);
            end;
        end;
      end;
    end;
    {if we reach this point we've either exhausted the deque or we've
     run out of string; we need to check the states left on the deque
     (if there are any) to see if one is the terminating state; if so
     the string matched the regular expressionn defined by the
     transition table}
    while not Deque.IsEmpty do begin
      State := Deque.Pop;
      if (State = aTable^.stFinalState) then begin
        Result := true;
        Exit;
      end;
    end;
  finally
    Deque.Free;
  end;
end;


var
  Table : PaaNFAStateTable;
  S     : string;

procedure SetEntry(aInx   : integer;
                   aType  : TaaNFAMatchType;
                   aChar  : char;
                   aClass : PaaCharSet;
                   aNext1 : integer;
                   aNext2 : integer);
begin
  with Table^.stTable[aInx] do begin
    sdNextState1 := aNext1;
    sdMatchType  := aType;
    case aType of
      mtNone     : sdNextState2 := aNext2;
      mtChar     : sdChar := aChar;
      mtClass    : sdClass := aClass;
      mtNegClass : sdClass := aClass;
    end;
  end;
end;


begin
  {build the table}
  Table := AllocMem(2 * sizeof(integer) +
                    8 * sizeof(TaaNFAStateData));
  SetEntry(0, mtChar, 'a', nil, 1, -1);
  SetEntry(1, mtNone, ' ', nil, 3, -1);
  SetEntry(2, mtChar, 'b', nil, 3, -1);
  SetEntry(3, mtNone, ' ', nil, 4, 5);
  SetEntry(4, mtNone, ' ', nil, 0, 2);
  SetEntry(5, mtChar, 'b', nil, 6, -1);
  SetEntry(6, mtChar, 'c', nil, 7, -1);
  SetEntry(7, mtNone, ' ', nil, -1, -1);
  Table^.stStartState := 3;
  Table^.stFinalState := 7;

  writeln('Matching (a|b)*bc...');
  S := 'bc';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'abc';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'aaaaaaaaaaabc';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'bbbbbbbbbbbbbbbbc';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'abababababababc';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'bac';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  S := 'cab';
  writeln(S, ': ', aaMatchRegEx(Table, S));
  readln;

  FreeMem(Table);
end.